;;;; Copyright 2009 Peter von Etter

;;;; This file is part of Autoproject

;;;; Autoproject is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation, either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; Autoproject is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with Autoproject.  If not, see
;;;; <http://www.gnu.org/licenses/>.

;;;; Automatically defines classes corresponding to tables with slots
;;;; corresponding to fields

(in-package :autoproject.crud)

(defclass crud ()
  (;; Hash of hashes representing the database structure. Keys are
   ;; symbols
   (field-symbols :accessor get-field-symbols 
                  :initform (make-hash-table :test 'eq))
   ;; Hash of hashes representing the database structure. Keys are
   ;; strings
   (field-names :accessor get-field-names 
                :initform (make-hash-table :test 'equal))
   ;; Hash mapping strings to table classes
   (table-classes :accessor get-table-classes 
                  :initform (make-hash-table :test 'equal))
   ;; For future use, currently we assume every table has an 'id'
   ;; field.
   (id-fields :accessor %get-id-fields 
              :initform (make-hash-table :test 'equal))
   
   (db-adapter :accessor get-db-adapter :initarg :db-adapter)))

(defclass db-response () ())

(defvar *target-package*)
(defvar *exports*)
(defvar *table-super-class-name* "TABLE-SUPER-CLASS")
(defvar *global-keyword-symbol-map-name* "*KEYWORD-SYMBOL-MAP*")
(defvar *debug* nil)

;;;; CRUD initialization.

(defgeneric make-crud (crud-class db-adapter &rest rest))
(defgeneric row-instance (class-name row))
(defgeneric instance-plist (instance))
(defgeneric instance-string-list (instance))
(defgeneric instance-plist-bound (instance))
(defgeneric instance-string-list-bound (instance))
(defgeneric get-table-name (instance))
(defgeneric get-id (instance))

(defgeneric get-slot-names (db-response &optional return-kind))
(defgeneric get-slot-symbols (i))
(defgeneric get-slot-strings (i))
(defgeneric get-slot-keywords (i))
(defgeneric get-slot-values (i))
(defgeneric get-number-of-slots (i))

(defgeneric get-crud-symbol (crud-or-item keyword))

(defun instance-list (i field-list)
  (loop :for kw :in field-list
     :for sn :in (get-slot-names i)
     :collect kw :collect (when (slot-boundp i sn)
                            (slot-value i sn))))

(defun instance-values (i)
  (loop :for sn :in (get-slot-names i)
     :collect (when (slot-boundp i sn)
                (slot-value i sn))))

(defun instance-list-bound (i field-list)
  (loop :for kw :in field-list
     :for sn :in (get-slot-names i)
     :when (slot-boundp i sn)
     :collect kw :and
     :collect (slot-value i sn)))

(defmethod instance-plist ((i db-response))
  (instance-list i (get-slot-keywords i)))

(defmethod instance-string-list ((i db-response))
  (instance-list i (get-slot-strings i)))

(defmethod instance-plist-bound ((i db-response))
  (instance-list-bound i (get-slot-keywords i)))

(defmethod instance-string-list-bound ((i db-response))
  (instance-list-bound i (get-slot-strings i)))

(defmethod get-slot-names (instance &optional (kind :symbol))
  (ecase kind
    (:symbol (get-slot-symbols instance))
    (:keyword (get-slot-keywords instance))
    (:string (get-slot-strings instance))))

;; *PACKAGE* should be bound to the target package
(defmethod create-crud-form (crud table-name fields)
  (let* ((class-name (symbolicate (lispify table-name)))
         (slot-names (mapcar (lambda (x)
                               (symbolicate (lispify x)))
                             fields))
         (initargs (mapcar (lambda (x)
                             (keywordify (lispify x))) fields))

         (number-of-slots (length fields))

         (field-slots
          (mapcar (lambda (x)
                    `(,x :initarg ,(keywordify (lispify x))
                         :accessor ,(intern
                                     (format nil "GET-~A"
                                             (lispify (string x))))))
                  slot-names))

         ;; 'i' is the instance variable
         ;; (instance-plist-form
         ;;  `(list ,@(loop :for kw :in initargs
         ;;              :for sn :in slot-names
         ;;              :collect kw :collect `(when (slot-boundp i ',sn)
         ;;                                      (slot-value i ',sn)))))
         ;; (instance-plist-bound-form
         ;;  `(loop :for kw :in ',initargs
         ;;      :for sn :in ',slot-names
         ;;      :when (slot-boundp i sn)
         ;;      :collect kw :and
         ;;      :collect (slot-value i sn)))
         ;; 
         ;; (instance-string-list-form
         ;;  `(list ,@(loop :for f :in fields
         ;;              :for sn :in slot-names
         ;;              :collect f :collect `(when (slot-boundp i ',sn)
         ;;                                     (slot-value i ',sn)))))
         ;; (instance-string-list-bound-form
         ;;  `(loop :for f :in ',fields
         ;;      :for sn :in ',slot-names
         ;;      :when (slot-boundp i sn)
         ;;      :collect f :and
         ;;      :collect (slot-value i sn)))
         
         (defclass-form
          `(progn
             (defclass ,class-name (#+nil db-response
                                          ,(intern *table-super-class-name*))
               ,field-slots)
             (defmethod row-instance ((i (eql ',class-name)) row)
               (apply #'make-instance ',class-name
                      (zip ',initargs row)))
             ;; (defmethod instance-plist ((i ,class-name))
             ;;   ,instance-plist-form)
             ;; (defmethod instance-string-list ((i ,class-name))
             ;;   ,instance-string-list-form)
             ;; (defmethod instance-plist-bound ((i ,class-name))
             ;;   ,instance-plist-bound-form)
             ;; (defmethod instance-string-list-bound ((i ,class-name))
             ;;   ,instance-string-list-bound-form)
             (defmethod get-slot-symbols ((i ,class-name))
               ',slot-names)
             (defmethod get-slot-strings ((i ,class-name))
               ',fields)
             (defmethod get-slot-keywords ((i ,class-name))
               ',initargs)             
             (defmethod get-table-name ((i ,class-name))
               ,table-name)
             (defmethod get-table-name ((i (eql ',class-name)))
               ,table-name)
             (defmethod get-number-of-slots ((i (eql ',class-name)))
               ,number-of-slots)
             (defmethod get-number-of-slots ((i ,class-name))
               ,number-of-slots)
             (defmethod get-id ((i ,class-name)) 
               (slot-value i ',(symbolicate "ID")))
             (defmethod get-slot-values ((i ,class-name)) 
               (instance-values i))))) 
    
    (when (boundp '*exports*)
      (push (lispify table-name) *exports*)
      (setf *exports* 
            (append (mapcar (lambda (x)
                              (format nil "GET-~A" (lispify x)))
                            fields) 
                    *exports*))
      (setf *exports* (append (mapcar 'lispify fields)
                              *exports*))) 

    defclass-form))

(defmethod define-table-class (crud table-name fields)
  (let* ((class-name (symbolicate table-name))
         (defclass-form (create-crud-form crud table-name fields)))
    (setf (gethash table-name (get-table-classes crud)) class-name)
    ;; (print defclass-form)
    (eval defclass-form)
    (find-class class-name)))

(defmethod define-table-classes (crud)
  (maphash (lambda (table field-hash)
             (define-table-class crud table 
               (listify-hash field-hash :kind :key)))
           (get-field-names crud)))

(defmethod %init-crud (crud tables fields-list)

  ;; Map keywords to real slot symbols
  ;; This should be the global static keyword map that is unique to each crud.
  (let ((keyword-symbol-map 
         ;; *package* should be set to the target package
         (or (let ((s (find-symbol *global-keyword-symbol-map-name*
                                   (symbol-package (class-name (class-of crud))))))
               (when (and s (boundp s))
                 (symbol-value s)))
             
             ;; This is a bit retarded, but needs to be here to make
             ;; the crud super class happy (it also runs this method).
             (make-hash-table :test 'eq))))
    
    (clrhash (get-field-names crud))
    (clrhash (get-field-symbols crud))
    
    (loop :for x :in tables
          :for fields :in fields-list
          :do
          (let ((namehash (make-hash-table :test 'equal))
                (symhash (make-hash-table :test 'eq)))       
            (setf (gethash x (get-field-names crud)) 
                  namehash)
            (setf (gethash (keywordify x) (get-field-symbols crud))
                  symhash)
       
            (setf (gethash x (get-table-classes crud))
                  (symbolicate (lispify x)))
            
            (setf (gethash (keywordify x) keyword-symbol-map)
                  (symbolicate (lispify x)))

            (dolist (f fields)
              (setf (gethash f namehash) t)
              (setf (gethash (keywordify f) symhash) t)
              (setf (gethash (keywordify f) keyword-symbol-map)
                    (symbolicate (lispify f))))))))


(defmethod create-crud-subclass-form (crud name tables fields)
  (push (lispify name) *exports*)
  (setf *exports* (remove-duplicates 
                   (append (sort (mapcar 'lispify tables) 'string<)
                           (sort *exports* 'string<))
                   :test 'equal))
  `((defpackage ,*target-package*
      (:use :cl)
      (:export ,@*exports*))     
    (in-package ,*target-package*)
    
    (defparameter ,(intern *global-keyword-symbol-map-name*)
      (make-hash-table :test 'eq))
    
    (defclass ,(intern name) (crud) ())
    (defmethod init-crud ((crud ,(intern name)))
      (let ((*package* (find-package ,*target-package*)))
        (%init-crud crud ',tables ',fields)))
    (defmethod initialize-instance :after ((crud ,(intern name)) &key)
      (init-crud crud))

    (defclass ,(intern *table-super-class-name*) (db-response) ())
    
    (defmethod get-crud-symbol ((table ,(intern *table-super-class-name*)) keyword)
      (gethash keyword ,(intern *global-keyword-symbol-map-name*)))

    (defmethod get-crud-symbol ((crud ,(intern name)) keyword)
      (gethash keyword ,(intern *global-keyword-symbol-map-name*)))))



(defmethod create-crud-forms (crud crud-subclass-name)
  "CRUD should be initialized with field data."
  (let ((result nil)
        (fields nil))
    (maphash (lambda (table field-hash)
               (let ((f (listify-hash field-hash 
                                      :kind :key)))
                 (push f fields)
                 (push (create-crud-form crud table f)
                       result)))
             (get-field-names crud))
    (setf result (nreverse result))

    (setf result
          (append (create-crud-subclass-form 
                   crud
                   crud-subclass-name
                   (listify-hash (get-field-names crud) :kind :key)
                   (nreverse fields))
                  result))
    result))

(defmethod get-fields (crud (table symbol))
  (gethash table (get-field-symbols crud)))

(defmethod get-fields (crud (table string))
  (gethash table (get-field-names crud)))

(defmethod get-id-field (crud table)
  "id")

(defmethod get-table-class (crud (table string))
  (gethash table (get-table-classes crud)))

(defmethod rows-instances (crud (table string) rows)
  (let ((class (get-table-class crud table)))
    (mapcar (lambda (x)
              (row-instance class x))
            rows)))

(defmethod rows-instances (crud (table symbol) rows)
  (mapcar (lambda (x) (row-instance table x))
          rows))

(defun row-multiple-instances (crud tables row)
  (declare (ignore crud))
  (let ((result))        
    (loop :for i :in tables
          :do (multiple-value-bind (a b)
                  (split-list row (get-number-of-slots i))
                (push (row-instance i a) result)
                (setf row b)))
    (nreverse result)))

(defmethod rows-multiple-instances (crud (tables list) rows)
  
  (typecase (first tables)
    (string (setf tables (mapcar 
                          (lambda (x) 
                            (get-table-class crud x))
                          tables)))
    (t nil))  
  (loop :for r :in rows
        :collect (row-multiple-instances crud tables r)))
                 
(defmethod init-crud (crud)
  (with-crud (crud)
    (read-database-tables crud)
    (define-table-classes crud)))

(defgeneric write-crud-forms (crud crud-subclass-name stream package tables fields))

(defmethod write-crud-forms (crud crud-subclass-name stream package tables fields)
  (let ((*print-readably* t)
        (*package* (find-package "AUTOPROJECT.CRUD.TEMP"))
        (*target-package* package)
        (*exports*))    
    (%init-crud crud tables fields)
    (dolist (f (create-crud-forms crud crud-subclass-name))
      (print f stream))))

(defmethod write-crud-forms-to-file (crud file class-name package-name)
  "Generates a crud source file named FILE from the database pointed to
by CRUD.  The crud class will be called CLASS-NAME and generated code
will go into the package PACKAGE-NAME.

A standard class will be generated for each database table, with slots
corresponding to fields in the table.  Accessors will also be
generated.  It is required that each table contain a primary integer
key field named 'id'."
  (multiple-value-bind (tables fields)
      (read-database-tables (get-db-adapter crud))
    (with-open-file (f file 
                       :direction :output
                       :if-exists :supersede)
      (write-crud-forms crud class-name f package-name tables fields)
      file)))

